home *** CD-ROM | disk | FTP | other *** search
/ CD Actual 44 / PC Actual CD 44.iso / Linux / Cygwin / full.exe / Disk1 / data1.cab / Tools / share / tix4.1 / Balloon.tcl next >
Encoding:
Text File  |  1998-12-04  |  12.1 KB  |  566 lines
  1. # Balloon.tcl --
  2. #
  3. #    The help widget. It provides both "balloon" type of help
  4. #    message and "status bar" type of help message. You can use
  5. #    this widget to indicate the function of the widgets inside
  6. #    your application.
  7. #
  8. # Copyright (c) 1996, Expert Interface Technologies
  9. #
  10. # See the file "license.terms" for information on usage and redistribution
  11. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  12. #
  13.  
  14.  
  15. tixWidgetClass tixBalloon {
  16.     -classname TixBalloon
  17.     -superclass tixShell
  18.     -method {
  19.     bind post unbind
  20.     }
  21.     -flag {
  22.     -installcolormap -initwait -state -statusbar
  23.     }
  24.     -configspec {
  25.     {-installcolormap installColormap InstallColormap false}
  26.     {-initwait initWait InitWait 1000}
  27.     {-state state State both}
  28.     {-statusbar statusBar StatusBar ""}
  29.  
  30.      {-cursor cursor Cursur left_ptr}
  31.     }
  32.     -default {
  33.     {*background             #ffff60}
  34.     {*foreground             black}
  35.     {*borderWidth             0}
  36.     {.borderWidth             1}
  37.     {.background             black}
  38.     {*Label.anchor            w}
  39.     {*Label.justify            left}
  40.     }
  41. }
  42.  
  43. # Class Record
  44. #
  45. set tixBalloon(bals) ""
  46.  
  47. proc tixBalloon:InitWidgetRec {w} {
  48.     upvar #0 $w data
  49.     global tixBalloon
  50.  
  51.     tixChainMethod $w InitWidgetRec
  52.  
  53.     set data(isActive)    0
  54.     set data(client)    ""
  55.  
  56.     lappend tixBalloon(bals) $w
  57. }
  58.  
  59. proc tixBalloon:ConstructWidget {w} {
  60.     upvar #0 $w data
  61.  
  62.     tixChainMethod $w ConstructWidget
  63.  
  64.     wm overrideredirect $w 1
  65.     wm withdraw $w
  66.  
  67.     # Frame 1 : arrow
  68.     frame $w.f1 -bd 0
  69.     set data(w:label) [label $w.f1.lab -bd 0 -relief flat \
  70.                -bitmap [tix getbitmap balarrow]]
  71.     pack $data(w:label) -side left -padx 1 -pady 1
  72.     
  73.     # Frame 2 : Message
  74.     frame $w.f2 -bd 0
  75.     set data(w:message) [label $w.f2.message -padx 0 -pady 0 -bd 0]
  76.     pack $data(w:message) -side left -expand yes -fill both -padx 10 -pady 1
  77.  
  78.     # Pack all
  79.     pack $w.f1 -fill both
  80.     pack $w.f2 -fill both    
  81.  
  82.     # This is an event tag used by the clients
  83.     #
  84.     bind TixBal$w <Destroy> "tixBalloon:ClientDestroy $w %W"
  85. }
  86.  
  87. proc tixBalloon:Destructor {w} {
  88.     global tixBalloon
  89.  
  90.     set bals ""
  91.     foreach b $tixBalloon(bals) {
  92.     if {$w != $b} {
  93.         lappend bals $b
  94.     }
  95.     }
  96.     set tixBalloon(bals) $bals
  97.  
  98.     tixChainMethod $w Destructor
  99. }
  100.  
  101. #----------------------------------------------------------------------
  102. # Config:
  103. #----------------------------------------------------------------------
  104. proc tixBalloon:config-state {w value} {
  105.     upvar #0 $w data
  106.  
  107.     case $value {
  108.     {none balloon status both} ""
  109.     default {
  110.        error "invalid value $value, must be none, balloon, status, or both"
  111.     }
  112.     }
  113. }
  114.  
  115. #----------------------------------------------------------------------
  116. # "RAW" event bindings:
  117. #----------------------------------------------------------------------
  118.  
  119. bind all <B1-Motion>         "+tixBalloon_XXMotion %X %Y 1"
  120. bind all <B2-Motion>         "+tixBalloon_XXMotion %X %Y 2"
  121. bind all <B3-Motion>         "+tixBalloon_XXMotion %X %Y 3"
  122. bind all <B4-Motion>         "+tixBalloon_XXMotion %X %Y 4"
  123. bind all <B5-Motion>         "+tixBalloon_XXMotion %X %Y 5"
  124. bind all <Any-Motion>         "+tixBalloon_XXMotion %X %Y 0"
  125. bind all <Leave>              "+tixBalloon_XXMotion %X %Y %b"
  126. bind all <Button>              "+tixBalloon_XXButton   %X %Y %b"
  127. bind all <ButtonRelease>    "+tixBalloon_XXButtonUp %X %Y %b"
  128.  
  129. proc tixBalloon_XXMotion {rootX rootY b} {
  130.     global tixBalloon
  131.  
  132.     foreach w $tixBalloon(bals) {
  133.     tixBalloon:XXMotion $w $rootX $rootY $b
  134.     }
  135. }
  136.  
  137. proc tixBalloon_XXButton {rootX rootY b} {
  138.     global tixBalloon
  139.  
  140.     foreach w $tixBalloon(bals) {
  141.     tixBalloon:XXButton $w $rootX $rootY $b
  142.     }
  143. }
  144.  
  145. proc tixBalloon_XXButtonUp {rootX rootY b} {
  146.     global tixBalloon
  147.  
  148.     foreach w $tixBalloon(bals) {
  149.     tixBalloon:XXButtonUp $w $rootX $rootY $b
  150.     }
  151. }
  152.  
  153.  
  154. # return true if d is a descendant of w
  155. #
  156. proc tixIsDescendant {w d} {
  157.     if [string match $w .] {
  158.     return 1
  159.     }
  160.     return [string match $w.* $d]
  161. }
  162.  
  163. # All the button events are fine if the ballooned widget is
  164. # a descendant of the grabbing widget
  165. #
  166. proc tixBalloon:GrabBad {w cw} {
  167.     global tixBalloon
  168.  
  169.     set g [grab current $w]
  170.     if {$g == ""} {
  171.     return 0
  172.     }
  173.     if [info exists tixBalloon(g_ignore,$g)] {
  174.     return 1
  175.     }
  176.     if [info exists tixBalloon(g_ignore,[winfo class $g])] {
  177.     return 1
  178.     }
  179.     if {$g == $cw || [tixIsDescendant $g $cw]} {
  180.     return 0
  181.     }
  182.     return 1
  183. }
  184.  
  185. proc tixBalloon:XXMotion {w rootX rootY b} {
  186.     upvar #0 $w data
  187.  
  188.     if {$data(-state) == "none"} {
  189.     return
  190.     }
  191.  
  192.     if {$b == 0} {
  193.     if [info exists data(b:1)] {unset data(b:1)}
  194.     if [info exists data(b:2)] {unset data(b:2)}
  195.     if [info exists data(b:3)] {unset data(b:3)}
  196.     if [info exists data(b:4)] {unset data(b:4)}
  197.     if [info exists data(b:5)] {unset data(b:5)}
  198.     }
  199.  
  200.  
  201.     if {[array names data b:*] != ""} {
  202.     # Some buttons are down. Do nothing
  203.     #
  204.     return
  205.     }
  206.  
  207.     set cw [winfo containing $rootX $rootY]
  208.     if [tixBalloon:GrabBad $w $cw] {
  209.     return
  210.     }
  211.  
  212.     # Find the a client window that matches
  213.     #
  214.     if {$w == $cw || [string match $w.* $cw]} {
  215.     # Cursor moved over the balloon -- Ignore
  216.     return
  217.     }
  218.  
  219.     while {$cw != ""} {
  220.     if [info exists data(m:$cw)] {
  221.         set client $cw
  222.         break
  223.     } else {
  224.         set cw [winfo parent $cw]
  225.     }
  226.     }
  227.     if {![info exists client]} {
  228.     # The cursor is at a position covered by a non-client
  229.     # Popdown the balloon if it is up
  230.     if {$data(isActive)} {
  231.         tixBalloon:Deactivate $w
  232.     }
  233.     set data(client) ""
  234.     if [info exists data(cancel)] {
  235.         unset data(cancel) 
  236.     }
  237.     return
  238.     }
  239.  
  240.     if {$data(client) != $client} {
  241.     if {$data(isActive)} {
  242.         tixBalloon:Deactivate $w
  243.     }
  244.     set data(client) $client
  245.     after $data(-initwait) tixBalloon:SwitchToClient $w $client
  246.     }
  247. }
  248.  
  249. proc tixBalloon:XXButton {w rootX rootY b} {
  250.     upvar #0 $w data
  251.  
  252.     tixBalloon:XXMotion $w $rootX $rootY $b
  253.  
  254.     set data(b:$b) 1
  255.  
  256.     if {$data(isActive)} {
  257.     tixBalloon:Deactivate $w
  258.     } else {
  259.     set data(cancel) 1
  260.     }
  261. }
  262.  
  263. proc tixBalloon:XXButtonUp {w rootX rootY b} {
  264.     upvar #0 $w data
  265.  
  266.     tixBalloon:XXMotion $w $rootX $rootY $b
  267.     if [info exists data(b:$b)] {
  268.     unset data(b:$b)
  269.     }
  270. }
  271.  
  272. #----------------------------------------------------------------------
  273. # "COOKED" event bindings:
  274. #----------------------------------------------------------------------
  275.  
  276. # switch the balloon to a new client
  277. #
  278. proc tixBalloon:SwitchToClient {w client} {
  279.     upvar #0 $w data
  280.  
  281.     if {![winfo exists $w]} {
  282.     return
  283.     }
  284.     if {![winfo exists $client]} {
  285.     return
  286.     }
  287.     if {$client != $data(client)} {
  288.     return
  289.     }
  290.     if [info exists data(cancel)] {
  291.     unset data(cancel)
  292.     return
  293.     }
  294.  
  295.     if [tixBalloon:GrabBad $w $w] {
  296.     return
  297.     }
  298.  
  299.     tixBalloon:Activate $w
  300. }
  301.  
  302. proc tixBalloon:ClientDestroy {w client} {
  303.     if {![winfo exists $w]} {
  304.     return
  305.     }
  306.  
  307.     upvar #0 $w data
  308.  
  309.     if {$data(client) == $client} {
  310.     tixBalloon:Deactivate $w
  311.     set data(client) ""
  312.     }
  313.  
  314.     # Maybe thses have already been unset by the Destroy method
  315.     #
  316.     if [info exists data(m:$client)] {unset data(m:$client)}
  317.     if [info exists data(s:$client)] {unset data(s:$client)}
  318. }
  319.  
  320. #----------------------------------------------------------------------
  321. # Popping up balloon:
  322. #----------------------------------------------------------------------
  323. proc tixBalloon:Activate {w} {
  324.     upvar #0 $w data
  325.  
  326.     if [tixBalloon:GrabBad $w $w] {
  327.     return
  328.     }
  329.     if {[winfo containing [winfo pointerx $w] [winfo pointery $w]] == ""} {
  330.     return
  331.     }
  332.  
  333.     switch $data(-state) {
  334.     "both" {
  335.         tixBalloon:PopUp $w
  336.         tixBalloon:SetStatus $w
  337.     }
  338.     "balloon" {
  339.         tixBalloon:PopUp $w
  340.     }
  341.     "status" {
  342.         tixBalloon:SetStatus $w
  343.     }
  344.     }
  345.  
  346.     set data(isActive) 1
  347.  
  348.     after 200 tixBalloon:Verify $w
  349. }
  350.  
  351.  
  352. # %% Perhaps this is no more needed
  353. #
  354. proc tixBalloon:Verify {w} {
  355.     upvar #0 $w data
  356.  
  357.     if {![winfo exists $w]} {
  358.     return
  359.     }
  360.     if {!$data(isActive)} {
  361.     return
  362.     }
  363.  
  364.     if [tixBalloon:GrabBad $w $w] {
  365.     tixBalloon:Deactivate $w
  366.     return
  367.     }
  368.     if {[winfo containing [winfo pointerx $w] [winfo pointery $w]] == ""} {
  369.     tixBalloon:Deactivate $w
  370.     return
  371.     }
  372.     after 200 tixBalloon:Verify $w
  373. }
  374.  
  375. proc tixBalloon:Deactivate {w} {
  376.     upvar #0 $w data
  377.  
  378.     tixBalloon:PopDown $w
  379.     tixBalloon:ClearStatus $w
  380.     set data(isActive) 0
  381.     if [info exists data(cancel)] {
  382.     unset data(cancel)
  383.     }
  384. }
  385.  
  386. proc tixBalloon:PopUp {w} {
  387.     upvar #0 $w data
  388.  
  389.     if [tixGetBoolean -nocomplain $data(-installcolormap)] {
  390.     wm colormapwindows [winfo toplevel $data(client)] $w
  391.     }
  392.  
  393.     # trick: the following lines allow the balloon window to
  394.     # acquire a stable width and height when it is finally
  395.     # put on the visible screen
  396.     #
  397.     set client $data(client)
  398.     $data(w:message) config -text $data(m:$client)
  399.     wm geometry $w +10000+10000
  400.     wm deiconify $w
  401.     raise $w
  402.     update
  403.  
  404.     # The windows may become destroyed as a result of the "update" command
  405.     #
  406.     if {![winfo exists $w]} {
  407.     return
  408.     }
  409.     if {![winfo exists $client]} {
  410.     return
  411.     }
  412.     # Put it on the visible screen
  413.     #
  414.     set x [expr [winfo rootx $client]+[winfo width  $client]/2]
  415.     set y [expr int([winfo rooty $client]+[winfo height $client]/1.3)]
  416.  
  417.     set width  [winfo reqwidth $w]
  418.     set height [winfo reqheight $w]
  419.     set scrwidth  [winfo vrootwidth  $w]
  420.     set scrheight [winfo vrootheight $w]
  421.  
  422.     # If the balloon is too far right, pull it back to the left
  423.     #
  424.     if {[expr $x + $width] > $scrwidth} {
  425.     set x [expr $scrwidth - $width]
  426.     }
  427.  
  428.     # If the balloon is too far left, pull it back to the right
  429.     #
  430.     if {$x < 0} {
  431.     set x 0
  432.     }
  433.  
  434.     # If the listbox is below bottom of screen, put it upwards
  435.     #
  436.     if {[expr $y + $height] > $scrheight} {
  437.     set y [expr $scrheight-$height]
  438.     }
  439.     if {$y < 0} {
  440.     set y 0
  441.     }
  442.  
  443.     wm geometry $w +$x+$y
  444. }
  445.  
  446. proc tixBalloon:PopDown {w} {
  447.     upvar #0 $w data
  448.  
  449.     # Close the balloon
  450.     #
  451.     wm withdraw $w
  452.  
  453.     # We don't set the data(client) to be zero, so that the balloon
  454.     # will re-appear only if you move out then in the client window
  455.     # set data(client) ""
  456. }
  457.  
  458. proc tixBalloon:SetStatus {w} {
  459.     upvar #0 $w data
  460.  
  461.     if {![winfo exists $data(-statusbar)]} {
  462.     return
  463.     }
  464.     if {![info exists data(s:$data(client))]} {
  465.     return
  466.     }
  467.  
  468.     set vv [$data(-statusbar) cget -textvariable]
  469.     if {$vv == ""} {
  470.     $data(-statusbar) config -text $data(s:$data(client))
  471.     } else {
  472.     uplevel #0 set $vv [list $data(s:$data(client))]
  473.     }
  474. }
  475.  
  476. proc tixBalloon:ClearStatus {w} {
  477.     upvar #0 $w data
  478.  
  479.     if {![winfo exists $data(-statusbar)]} {
  480.     return
  481.     }
  482.  
  483.     # Clear the StatusBar widget
  484.     #
  485.     set vv [$data(-statusbar) cget -textvariable]
  486.     if {$vv == ""} {
  487.     $data(-statusbar) config -text ""
  488.     } else {
  489.     uplevel #0 set $vv [list ""]
  490.     }
  491. }
  492.  
  493. #----------------------------------------------------------------------
  494. # PublicMethods:
  495. #----------------------------------------------------------------------
  496.  
  497. # %% if balloon is already popped-up for this client, change mesage
  498. #
  499. proc tixBalloon:bind {w client args} {
  500.     upvar #0 $w data
  501.  
  502.     if [info exists data(m:$client)] {
  503.     set alreadyBound 1
  504.     } else {
  505.     set alreadyBound 0
  506.     }
  507.  
  508.     set opt(-balloonmsg) ""
  509.     set opt(-statusmsg)  ""
  510.     set opt(-msg)        ""
  511.  
  512.     tixHandleOptions opt {-balloonmsg -msg -statusmsg} $args
  513.  
  514.     if {$opt(-balloonmsg) != ""} {
  515.     set data(m:$client) $opt(-balloonmsg)
  516.     } else {
  517.     set data(m:$client) $opt(-msg)
  518.     }
  519.     if {$opt(-statusmsg) != ""} {
  520.     set data(s:$client) $opt(-statusmsg)
  521.     } else {
  522.     set data(s:$client) $opt(-msg)
  523.     }
  524.  
  525.     tixAppendBindTag $client TixBal$w
  526. }
  527.  
  528. proc tixBalloon:post {w client} {
  529.     upvar #0 $w data
  530.  
  531.     if {![info exists data(m:$client)]} {
  532.     return
  533.     }
  534.     tixBalloon:Enter $w $client
  535.     incr data(fakeEnter)
  536. }
  537.  
  538. proc tixBalloon:unbind {w client} {
  539.     upvar #0 $w data
  540.  
  541.     if [info exists data(m:$client)] {
  542.     if [info exists data(m:$client)] {unset data(m:$client)}
  543.     if [info exists data(s:$client)] {unset data(s:$client)}
  544.  
  545.     if [winfo exists $client] {
  546.         catch {tixDeleteBindTag $client TixBal$w}
  547.     }
  548.     }
  549. }
  550.  
  551. #----------------------------------------------------------------------
  552. #
  553. # Utility function
  554. #
  555. #----------------------------------------------------------------------
  556. #
  557. # $w can be a widget name or a classs name
  558. proc tixBalIgnoreWhenGrabbed {wc} {
  559.     global tixBalloon
  560.     set tixBalloon(g_ignore,$wc) ""
  561. }
  562.  
  563. tixBalIgnoreWhenGrabbed TixComboBox
  564. tixBalIgnoreWhenGrabbed Menu
  565. tixBalIgnoreWhenGrabbed Menubutton
  566.